home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / utils / with-timeout.el < prev    next >
Encoding:
Text File  |  1995-04-17  |  3.3 KB  |  80 lines
  1. ;;; with-timeout.el --- timeout hackery
  2.  
  3. ;; Copyright (C) 1992 Free Software Foundation, Inc.
  4. ;; Keywords: extensions
  5.  
  6. ;; This file is part of XEmacs.
  7.  
  8. ;; XEmacs is free software; you can redistribute it and/or modify it
  9. ;; under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation; either version 2, or (at your option)
  11. ;; any later version.
  12.  
  13. ;; XEmacs is distributed in the hope that it will be useful, but
  14. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16. ;; General Public License for more details.
  17.  
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  20. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. (defun with-timeout-timer (tag)
  23.   ;; I'm pretty sure the condition-case isn't really necessary here,
  24.   ;; but it doesn't hurt.
  25.   (condition-case () (throw tag nil) (no-catch nil)))
  26.  
  27. ;;;###autoload
  28. (defun with-timeout-internal (with-timeout-seconds with-timeout-tag
  29.                                with-timeout-body with-timeout-forms)
  30.   (let ((with-timeout-timeout nil))
  31.     (unwind-protect
  32.          (progn
  33.            (setq with-timeout-timeout (add-timeout with-timeout-seconds
  34.                                                    'with-timeout-timer
  35.                                                    with-timeout-tag))
  36.            (let ((value (catch with-timeout-tag
  37.                           (prog1 (funcall with-timeout-body)
  38.                             (setq with-timeout-tag nil)))))
  39.              (if with-timeout-tag
  40.                  (funcall with-timeout-forms)
  41.          value)))
  42.       (if with-timeout-timeout
  43.           (disable-timeout with-timeout-timeout)))))
  44.  
  45. ;;;###autoload
  46. (defmacro with-timeout (seconds-and-timeout-forms &rest body)
  47.   "Usage: (with-timeout (seconds &rest timeout-forms) &rest body)
  48. This is just like progn, but if the given number of seconds expires before
  49. the body returns, then timeout-forms are evaluated and returned instead.
  50. The body won't be interrupted in the middle of a computation: the check for 
  51. the timer expiration only occurs when body does a redisplay, or prompts the
  52. user for input, or calls accept-process-output."
  53.   (let ((seconds (car seconds-and-timeout-forms))
  54.     (timeout-forms (cdr seconds-and-timeout-forms)))
  55.     (` (with-timeout-internal (, seconds) '(, (make-symbol "_with_timeout_"))
  56.                               #'(lambda () (progn (,@ body)))
  57.                               #'(lambda () (progn (,@ timeout-forms)))))))
  58.  
  59. (put 'with-timeout 'lisp-indent-function 1)
  60.  
  61. ;;;###autoload
  62. (defun yes-or-no-p-with-timeout (timeout prompt &optional default-value)
  63.   "Just like yes-or-no-p, but will time out after TIMEOUT seconds
  64. if the user has not yes answered, returning DEFAULT-VALUE."
  65.   (with-timeout (timeout
  66.          (message (concat prompt "(yes or no) Timeout to "
  67.                   (if default-value "Yes" "No")))
  68.          default-value)
  69.     (yes-or-no-p prompt)))
  70.  
  71. ;;;###autoload
  72. (defun y-or-n-p-with-timeout (timeout prompt &optional default-value)
  73.   "Just like y-or-n-p, but will time out after TIMEOUT seconds
  74. if the user has not yes answered, returning DEFAULT-VALUE."
  75.   (with-timeout (timeout
  76.          (message (concat prompt "(yes or no) Timeout to "
  77.                   (if default-value "Yes" "No")))
  78.          default-value)
  79.     (y-or-n-p prompt)))
  80.